{-# LANGUAGE TypeOperators              #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Orca.Csound.Syntax
-- Copyright   :  (c) Stephen Tetley 2013
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Syntax datatypes and pretty printer.
--
--------------------------------------------------------------------------------

module Orca.Csound.Syntax
  (
    
    Decimal
  , SPair(..)
  , (:::)
  , RateId(..)
  , VarId(..)
  , PrimId
  , primId

  , Stmt(..)
  , Rhs(..)
  , OpCall(..)
  , Expr(..)
  , Value(..)
  , UnaryOp(..)
  , BinOp(..)
  , RelOp(..)

  , GetRateId(..)

  , ppStmts
  , ppStmt
    
  ) where

import Orca.Csound.CsoundPP
import Orca.Csound.Utils

import Text.PrettyExprHPJ                   -- package: pretty-expr-hpj

import Text.PrettyPrint.HughesPJ            -- pacakge: pretty
import qualified Text.PrettyPrint.HughesPJ as P


import Data.Fixed
import Data.Function
import Data.List ( intersperse )
import Data.Monoid


type Decimal = Fixed E9 


-- Strict pair with special constructor syntax

data SPair a b = !a ::: ! b 
  deriving (Eq,Ord,Show)

infixr 4 :::

type (:::) a b = SPair a b


instance (Monoid a, Monoid b) => Monoid (SPair a b) where
  mempty = mempty ::: mempty
  (a1 ::: b1) `mappend` (a2 ::: b2) = (a1 `mappend` a2) ::: (b1 `mappend` b2)



-- | Decl site used to determine when to prefix the var name with
-- a @g@. 
--
data RateId = I_RATE | K_RATE | A_RATE
  deriving (Enum,Eq,Ord,Show)



data VarId = Global  { var_rate  :: RateId
                     , var_name  :: String
                     }
           | Local   { var_rate  :: RateId
                     , var_num   :: Int
                     }
           | DeclVar { var_rate  :: RateId
                     , var_name  :: String
                     }
  deriving (Eq,Ord,Show)



newtype PrimId = PrimId { prim_name   :: String }
  deriving (Eq,Ord,Show)

primId :: String -> PrimId
primId = PrimId


-- Ideally Assign (Rhs) would be rate-tagged so we can generate
-- fresh variables.
--
-- Assign2 has only OpCalls on rhs as Csound has no tuple 
-- contruct.
--
data Stmt = Assign   VarId  Rhs
          | Assign2  VarId  VarId  OpCall
          | Assign3  VarId  VarId  VarId  OpCall
          | Assign4  VarId  VarId  VarId  VarId  OpCall
          | InvokeO  PrimId [Expr]              -- invoke an opcode e.g. out
  deriving (Eq,Show)


data Rhs = PureRhs  Expr
         | OpCallRhs OpCall
  deriving (Eq,Show)

data OpCall = OpCall RateId PrimId [Expr]
  deriving (Eq,Show)

data Expr = Value   RateId  Value
          | UnaryE  UnaryOp Expr
          | BinaryE BinOp   Expr   Expr
          | RelE    RelOp   Expr   Expr
          | CondE   Expr    Expr   Expr
          | FunCall RateId  PrimId [Expr]
          | Cast    RateId  Expr
  deriving (Eq,Show)

data Value = Unit
           | Bool Bool
           | Int Int
           | Float Decimal
           | String String
           | Pfield Int
           | Var VarId
  deriving (Eq,Show)


-- | Negation and Bitwise NOT.
--
data UnaryOp = NEG | BNOT
  deriving (Eq,Show)


-- | No power of @(^)@ as its use is discouraged.
--
data BinOp = ADD | SUB | MUL | DIV | LOG_AND | LOG_OR | MODULUS 
  deriving (Enum,Eq,Ord,Show)

data RelOp = EQU | NEQU | LESSTHAN | GREATTHAN | LTEQU | GTEQU
  deriving (Enum,Eq,Ord,Show)


class GetRateId e where
  getRateId :: e -> RateId

highestRate :: RateId -> RateId -> RateId
highestRate A_RATE _      = A_RATE
highestRate _      A_RATE = A_RATE
highestRate K_RATE _      = K_RATE
highestRate _      K_RATE = K_RATE
highestRate I_RATE I_RATE = I_RATE


instance GetRateId Expr where
  getRateId (Value rid _)       = rid
  getRateId (UnaryE  _ e)       = getRateId e
  getRateId (BinaryE _ e1 e2)   = on highestRate getRateId e1 e2
  getRateId (RelE _ e1 e2)      = on highestRate getRateId e1 e2
  getRateId (CondE _ e1 e2)     = on highestRate getRateId e1 e2
  getRateId (FunCall rid _ _)   = rid
  getRateId (Cast rid _)        = rid



instance GetRateId Rhs where
  getRateId (PureRhs e)         = getRateId e
  getRateId (OpCallRhs body)    = getRateId body


instance GetRateId OpCall where
  getRateId (OpCall rid _ _)  = rid


-- | Calling a Opcode is considered effectful. 
-- It is pretty printed as an op-call (no equals sign is 
-- printed).  
--
effectful :: Rhs -> Bool
effectful (OpCallRhs {}) = True
effectful _              = False


-- | Identifiers whose type cannot be rendered to Csound 
-- prim-types get name mangled.
--
varName :: VarId -> String
varName (Global _ ss)    = ss
varName (Local ri i)     = rateName ri : 'Z' : show i
varName (DeclVar _ ss)   = ss

rateName :: RateId -> Char
rateName I_RATE = 'i'
rateName K_RATE = 'k'
rateName A_RATE = 'a'


--------------------------------------------------------------------------------
-- Pretty print

ppStmts :: [Stmt] -> Doc
ppStmts []     = empty
ppStmts [x]    = ppStmt x
ppStmts (x:xs) = ppStmt x $+$ ppStmts xs

ppStmt :: Stmt -> Doc
ppStmt (Assign v e)                 = assignLine v e
ppStmt (Assign2 v1 v2 body)         = assignLineN [v1,v2] (ppOpCall body)
ppStmt (Assign3 v1 v2 v3 body)      = assignLineN [v1,v2,v3] (ppOpCall body)
ppStmt (Assign4 v1 v2 v3 v4 body)   = assignLineN [v1,v2,v3,v4] (ppOpCall body)
ppStmt (InvokeO s xs)               = opCall s xs



assignLine :: VarId -> Rhs -> Doc
assignLine v rhs
    | effectful rhs             = effectLine v $ ppRhs rhs
    | otherwise                 = equalsLine v $ ppRhs rhs

effectLine :: VarId -> Doc -> Doc
effectLine vid d = padTextR 11 (varName vid) <+> d

equalsLine :: VarId -> Doc -> Doc
equalsLine vid d = padTextR 11 (varName vid) <+> equals <+> d


assignLineN :: [VarId] -> Doc -> Doc
assignLineN vs d = padTextR 11 lhs <+> d
  where
    lhs = concat $ intersperse ", " $ map varName vs


-- ppVarId :: VarId -> Doc
-- ppVarId = text . varName



ppRhs :: Rhs -> Doc
ppRhs (OpCallRhs body)   = ppOpCall body
ppRhs (PureRhs e)        = ppExpr e

ppOpCall :: OpCall -> Doc
ppOpCall (OpCall _ pid xs) = opCall pid xs

ppExpr :: Expr -> Doc
ppExpr = unparse . exprDocE

exprDocE :: Expr -> DocE
exprDocE (Value _ v)          = Atom $ ppValue v
exprDocE (UnaryE op e)        = unaryDocE op (exprDocE e)
exprDocE (BinaryE op e1 e2)   = binDocE op (exprDocE e1) (exprDocE e2)
exprDocE (RelE op e1 e2)      = relDocE op (exprDocE e1) (exprDocE e2)
exprDocE (FunCall _ pid es)   = 
    Atom $ text (prim_name pid) P.<> tupled (map ppExpr es)

exprDocE (CondE ce e1 e2)     = 
    Atom $ parens (ppExpr ce <+> char '?'   <+> ppExpr e1
                             <+> char ':'   <+> ppExpr e2 )

exprDocE (Cast _ e)           = exprDocE e

opCall :: PrimId -> [Expr] -> Doc
opCall s xs = text (prim_name s) <+> commaSep (map ppExpr xs)

ppValue :: Value -> Doc
ppValue (Unit)        = text "()"
ppValue (Bool True)   = int 1  
ppValue (Bool False)  = int 0
ppValue (Int i)       = int i
ppValue (Float d)     = truncatedDouble $ realToFrac d
ppValue (String ss)   = doubleQuotes $ text ss
ppValue (Pfield i)    = text $ 'p' : show i
ppValue (Var v)       = text $ varName v 



unaryDocE :: UnaryOp -> DocE -> DocE
unaryDocE NEG   = negateU
unaryDocE BNOT  = bitwiseNotU


binDocE :: BinOp -> DocE -> DocE -> DocE
binDocE ADD         = addB
binDocE SUB         = subtractB
binDocE MUL         = multiplyB
binDocE DIV         = divideB
binDocE LOG_AND     = logicalAndB
binDocE LOG_OR      = logicalOrB
binDocE MODULUS     = moduloB


relDocE :: RelOp -> DocE -> DocE -> DocE
relDocE EQU         = equalB
relDocE NEQU        = notEqualB
relDocE LESSTHAN    = lessThanB
relDocE GREATTHAN   = greaterThanB
relDocE LTEQU       = lessThanEqB
relDocE GTEQU       = greaterThanEqB

